home *** CD-ROM | disk | FTP | other *** search
/ Chip 2002 June / Chip_2002-06_cd1.bin / zkuste / delphi / kolekce / d6 / rxlibsetup.exe / {app} / units / RXVERINF.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  2002-02-19  |  12.0 KB  |  431 lines

  1. {*******************************************************}
  2. {                                                       }
  3. {         Delphi VCL Extensions (RX)                    }
  4. {                                                       }
  5. {         Copyright (c) 2001,2002 SGB Software          }
  6. {         Copyright (c) 1997, 1998 Fedor Koshevnikov,   }
  7. {                        Igor Pavluk and Serge Korolev  }
  8. {                                                       }
  9. {*******************************************************}
  10.  
  11.  
  12. unit RxVerInf;
  13.  
  14. {$I RX.INC}
  15.  
  16. {$IFDEF RX_D3}
  17.   {$WEAKPACKAGEUNIT}
  18. {$ENDIF}
  19.  
  20. interface
  21.  
  22. uses Windows;
  23.  
  24. type
  25.   TVersionLanguage = (vlArabic, vlBulgarian, vlCatalan, vlTraditionalChinese,
  26.     vlCzech, vlDanish, vlGerman, vlGreek, vlUSEnglish, vlCastilianSpanish,
  27.     vlFinnish, vlFrench, vlHebrew, vlHungarian, vlIcelandic, vlItalian,
  28.     vlJapanese, vlKorean, vlDutch, vlNorwegianBokmel, vlPolish,
  29.     vlBrazilianPortuguese, vlRhaetoRomanic, vlRomanian, vlRussian,
  30.     vlCroatoSerbian, vlSlovak, vlAlbanian, vlSwedish, vlThai, vlTurkish,
  31.     vlUrdu, vlBahasa, vlSimplifiedChinese, vlSwissGerman, vlUKEnglish,
  32.     vlMexicanSpanish, vlBelgianFrench, vlSwissItalian, vlBelgianDutch,
  33.     vlNorwegianNynorsk, vlPortuguese, vlSerboCroatian, vlCanadianFrench,
  34.     vlSwissFrench, vlUnknown);
  35.  
  36.   TVersionCharSet = (vcsASCII, vcsJapan, vcsKorea, vcsTaiwan, vcsUnicode,
  37.     vcsEasternEuropean, vcsCyrillic, vcsMultilingual, vcsGreek, vcsTurkish,
  38.     vcsHebrew, vcsArabic, vcsUnknown);
  39.  
  40. {$IFNDEF WIN32}
  41.   PVSFixedFileInfo = Pvs_FixedFileInfo;
  42.   DWORD = Longint;
  43. {$ENDIF}
  44.  
  45.   TLongVersion = record
  46.     case Integer of
  47.     0: (All: array[1..4] of Word);
  48.     1: (MS, LS: LongInt);
  49.   end;
  50.  
  51. { TVersionInfo }
  52.  
  53.   TVersionInfo = class(TObject)
  54.   private
  55.     FFileName: PChar;
  56.     FValid: Boolean;
  57.     FSize: DWORD;
  58.     FBuffer: PChar;
  59.     FHandle: DWORD;
  60.     procedure ReadVersionInfo;
  61.     function GetFileName: string;
  62.     procedure SetFileName(const Value: string);
  63.     function GetTranslation: Pointer;
  64.     function GetFixedFileInfo: PVSFixedFileInfo;
  65.     function GetFileLongVersion: TLongVersion;
  66.     function GetProductLongVersion: TLongVersion;
  67.     function GetTranslationString: string;
  68.     function GetComments: string;
  69.     function GetCompanyName: string;
  70.     function GetFileDescription: string;
  71.     function GetFileVersion: string;
  72.     function GetVersionNum: Longint;
  73.     function GetInternalName: string;
  74.     function GetLegalCopyright: string;
  75.     function GetLegalTrademarks: string;
  76.     function GetOriginalFilename: string;
  77.     function GetProductVersion: string;
  78.     function GetProductName: string;
  79.     function GetSpecialBuild: string;
  80.     function GetPrivateBuild: string;
  81.     function GetVersionLanguage: TVersionLanguage;
  82.     function GetVersionCharSet: TVersionCharSet;
  83.     function GetVerFileDate: TDateTime;
  84.   public
  85.     constructor Create(const AFileName: string);
  86.     destructor Destroy; override;
  87.     function GetVerValue(const VerName: string): string;
  88.     property FileName: string read GetFileName write SetFileName;
  89.     property Valid: Boolean read FValid;
  90.     property FixedFileInfo: PVSFixedFileInfo read GetFixedFileInfo;
  91.     property FileLongVersion: TLongVersion read GetFileLongVersion;
  92.     property ProductLongVersion: TLongVersion read GetProductLongVersion;
  93.     property Translation: Pointer read GetTranslation;
  94.     property VersionLanguage: TVersionLanguage read GetVersionLanguage;
  95.     property VersionCharSet: TVersionCharSet read GetVersionCharSet;
  96.     property VersionNum: Longint read GetVersionNum;
  97.     property Comments: string read GetComments;
  98.     property CompanyName: string read GetCompanyName;
  99.     property FileDescription: string read GetFileDescription;
  100.     property FileVersion: string read GetFileVersion;
  101.     property InternalName: string read GetInternalName;
  102.     property LegalCopyright: string read GetLegalCopyright;
  103.     property LegalTrademarks: string read GetLegalTrademarks;
  104.     property OriginalFilename: string read GetOriginalFilename;
  105.     property ProductVersion: string read GetProductVersion;
  106.     property ProductName: string read GetProductName;
  107.     property SpecialBuild: string read GetSpecialBuild;
  108.     property PrivateBuild: string read GetPrivateBuild;
  109.     property Values[const Name: string]: string read GetVerValue;
  110.     property VerFileDate: TDateTime read GetVerFileDate;
  111.   end;
  112.  
  113. function LongVersionToString(const Version: TLongVersion): string;
  114. function StringToLongVersion(const Str: string): TLongVersion;
  115. function AppFileName: string;
  116. function AppVerInfo: TVersionInfo;
  117.  
  118. { Installation utility routine }
  119.  
  120. function OkToWriteModule(ModuleName: string; NewVer: Longint): Boolean;
  121.  
  122. implementation
  123.  
  124. {$IFDEF WIN32}
  125. uses SysUtils, FileUtil, DateUtil;
  126. {$ELSE}
  127. uses WinTypes, WinProcs, SysUtils, FileUtil, DateUtil, VclUtils;
  128. {$ENDIF}
  129.  
  130. function MemAlloc(Size: Longint): Pointer;
  131. {$IFDEF WIN32}
  132. begin
  133.   GetMem(Result, Size);
  134. end;
  135. {$ELSE}
  136. var
  137.   Handle: THandle;
  138. begin
  139.   if Size < 65535 then GetMem(Result, Size)
  140.   else begin
  141.     Handle := GlobalAlloc(HeapAllocFlags, Size);
  142.     Result := GlobalLock(Handle);
  143.   end;
  144. end;
  145. {$ENDIF WIN32}
  146.  
  147. const
  148.   LanguageValues: array[TVersionLanguage] of Word = ($0401, $0402, $0403,
  149.     $0404, $0405, $0406, $0407, $0408, $0409, $040A, $040B, $040C, $040D,
  150.     $040E, $040F, $0410, $0411, $0412, $0413, $0414, $0415, $0416, $0417,
  151.     $0418, $0419, $041A, $041B, $041C, $041D, $041E, $041F, $0420, $0421,
  152.     $0804, $0807, $0809, $080A, $080C, $0810, $0813, $0814, $0816, $081A,
  153.     $0C0C, $100C, $0000);
  154.  
  155. const
  156.   CharacterSetValues: array[TVersionCharSet] of Integer = (0, 932, 949, 950,
  157.     1200, 1250, 1251, 1252, 1253, 1254, 1255, 1256, -1);
  158.  
  159. { TVersionInfo }
  160.  
  161. constructor TVersionInfo.Create(const AFileName: string);
  162. begin
  163.   inherited Create;
  164.   FFileName := StrPCopy(StrAlloc(Length(AFileName) + 1), AFileName);
  165.   ReadVersionInfo;
  166. end;
  167.  
  168. destructor TVersionInfo.Destroy;
  169. begin
  170.   if FBuffer <> nil then FreeMem(FBuffer, FSize);
  171.   StrDispose(FFileName);
  172.   inherited Destroy;
  173. end;
  174.  
  175. procedure TVersionInfo.ReadVersionInfo;
  176. begin
  177.   FValid := False;
  178.   FSize := GetFileVersionInfoSize(FFileName, FHandle);
  179.   if FSize > 0 then
  180.     try
  181.       FBuffer := MemAlloc(FSize);
  182.       FValid := GetFileVersionInfo(FFileName, FHandle, FSize, FBuffer);
  183.     except
  184.       FValid := False;
  185.       raise;
  186.     end;
  187. end;
  188.  
  189. function TVersionInfo.GetFileName: string;
  190. begin
  191.   Result := StrPas(FFileName);
  192. end;
  193.  
  194. procedure TVersionInfo.SetFileName(const Value: string);
  195. begin
  196.   if FBuffer <> nil then FreeMem(FBuffer, FSize);
  197.   FBuffer := nil;
  198.   StrDispose(FFileName);
  199.   FFileName := StrPCopy(StrAlloc(Length(Value) + 1), Value);
  200.   ReadVersionInfo;
  201. end;
  202.  
  203. function TVersionInfo.GetTranslation: Pointer;
  204. var
  205. {$IFDEF WIN32}
  206.   Len: UINT;
  207. {$ELSE}
  208.   Len: Cardinal;
  209. {$ENDIF}
  210. begin
  211.   Result := nil;
  212.   if Valid then VerQueryValue(FBuffer, '\VarFileInfo\Translation', Result, Len)
  213.   else Result := nil;
  214. end;
  215.  
  216. function TVersionInfo.GetTranslationString: string;
  217. var
  218.   P: Pointer;
  219. begin
  220.   Result := '';
  221.   P := GetTranslation;
  222.   if P <> nil then
  223.     Result := IntToHex(MakeLong(HiWord(Longint(P^)), LoWord(Longint(P^))), 8);
  224. end;
  225.  
  226. function TVersionInfo.GetVersionLanguage: TVersionLanguage;
  227. var
  228.   P: Pointer;
  229. begin
  230.   P := GetTranslation;
  231.   for Result := vlArabic to vlUnknown do
  232.     if LoWord(Longint(P^)) = LanguageValues[Result] then Break;
  233. end;
  234.  
  235. function TVersionInfo.GetVersionCharSet: TVersionCharSet;
  236. var
  237.   P: Pointer;
  238. begin
  239.   P := GetTranslation;
  240.   for Result := vcsASCII to vcsUnknown do
  241.     if HiWord(Longint(P^)) = CharacterSetValues[Result] then Break;
  242. end;
  243.  
  244. function TVersionInfo.GetFixedFileInfo: PVSFixedFileInfo;
  245. var
  246. {$IFDEF WIN32}
  247.   Len: UINT;
  248. {$ELSE}
  249.   Len: Cardinal;
  250. {$ENDIF}
  251. begin
  252.   Result := nil;
  253.   if Valid then VerQueryValue(FBuffer, '\', Pointer(Result), Len)
  254.   else Result := nil;
  255. end;
  256.  
  257. function TVersionInfo.GetProductLongVersion: TLongVersion;
  258. begin
  259.   Result.MS := FixedFileInfo^.dwProductVersionMS;
  260.   Result.LS := FixedFileInfo^.dwProductVersionLS;
  261. end;
  262.  
  263. function TVersionInfo.GetFileLongVersion: TLongVersion;
  264. begin
  265.   Result.MS := FixedFileInfo^.dwFileVersionMS;
  266.   Result.LS := FixedFileInfo^.dwFileVersionLS;
  267. end;
  268.  
  269. function TVersionInfo.GetVersionNum: Longint;
  270. begin
  271.   if Valid then Result := FixedFileInfo^.dwFileVersionMS
  272.   else Result := 0;
  273. end;
  274.  
  275. function TVersionInfo.GetVerValue(const VerName: string): string;
  276. var
  277.   szName: array[0..255] of Char;
  278.   Value: Pointer;
  279. {$IFDEF WIN32}
  280.   Len: UINT;
  281. {$ELSE}
  282.   Len: Cardinal;
  283. {$ENDIF}
  284. begin
  285.   Result := '';
  286.   if Valid then begin
  287.     StrPCopy(szName, '\StringFileInfo\' + GetTranslationString + '\' + VerName);
  288.     if VerQueryValue(FBuffer, szName, Value, Len) then
  289.       Result := StrPas(PChar(Value));
  290.   end;
  291. end;
  292.  
  293. function TVersionInfo.GetComments: string;
  294. begin
  295.   Result := GetVerValue('Comments');
  296. end;
  297.  
  298. function TVersionInfo.GetCompanyName: string;
  299. begin
  300.   Result := GetVerValue('CompanyName');
  301. end;
  302.  
  303. function TVersionInfo.GetFileDescription: string;
  304. begin
  305.   Result := GetVerValue('FileDescription');
  306. end;
  307.  
  308. function TVersionInfo.GetFileVersion: string;
  309. begin
  310.   Result := GetVerValue('FileVersion');
  311.   if (Result = '') and Valid then
  312.     Result := LongVersionToString(FileLongVersion);
  313. end;
  314.  
  315. function TVersionInfo.GetInternalName: string;
  316. begin
  317.   Result := GetVerValue('InternalName');
  318. end;
  319.  
  320. function TVersionInfo.GetLegalCopyright: string;
  321. begin
  322.   Result := GetVerValue('LegalCopyright');
  323. end;
  324.  
  325. function TVersionInfo.GetLegalTrademarks: string;
  326. begin
  327.   Result := GetVerValue('LegalTrademarks');
  328. end;
  329.  
  330. function TVersionInfo.GetOriginalFilename: string;
  331. begin
  332.   Result := GetVerValue('OriginalFilename');
  333. end;
  334.  
  335. function TVersionInfo.GetProductVersion: string;
  336. begin
  337.   Result := GetVerValue('ProductVersion');
  338.   if (Result = '') and Valid then
  339.     Result := LongVersionToString(ProductLongVersion);
  340. end;
  341.  
  342. function TVersionInfo.GetProductName: string;
  343. begin
  344.   Result := GetVerValue('ProductName');
  345. end;
  346.  
  347. function TVersionInfo.GetSpecialBuild: string;
  348. begin
  349.   Result := GetVerValue('SpecialBuild');
  350. end;
  351.  
  352. function TVersionInfo.GetPrivateBuild: string;
  353. begin
  354.   Result := GetVerValue('PrivateBuild');
  355. end;
  356.  
  357. function TVersionInfo.GetVerFileDate: TDateTime;
  358. begin
  359.   if FileExists(FileName) then
  360.     Result := FileDateTime(FileName)
  361.   else Result := NullDate;
  362. end;
  363.  
  364. { Long version string routines }
  365.  
  366. function LongVersionToString(const Version: TLongVersion): string;
  367. begin
  368.   with Version do
  369.     Result := Format('%d.%d.%d.%d', [All[2], All[1], All[4], All[3]]);
  370. end;
  371.  
  372. function StringToLongVersion(const Str: string): TLongVersion;
  373. var
  374.   Sep: Integer;
  375.   Tmp, Fragment: string;
  376.   I: Word;
  377. begin
  378.   Tmp := Str;
  379.   for I := 1 to 4 do begin
  380.     Sep := Pos('.', Tmp);
  381.     if Sep = 0 then Sep := Pos(',', Tmp);
  382.     if Sep = 0 then Fragment := Tmp
  383.     else begin
  384.       Fragment := Copy(Tmp, 1, Sep - 1);
  385.       Tmp := Copy(Tmp, Sep + 1, MaxInt);
  386.     end;
  387.     if Fragment = '' then Result.All[I] := 0
  388.     else Result.All[I] := StrToInt(Fragment);
  389.   end;
  390.   I := Result.All[1];
  391.   Result.All[1] := Result.All[2];
  392.   Result.All[2] := I;
  393.   I := Result.All[3];
  394.   Result.All[3] := Result.All[4];
  395.   Result.All[4] := I;
  396. end;
  397.  
  398. function AppFileName: string;
  399. var
  400.   FileName: array[0..255] of Char;
  401. begin
  402.   if IsLibrary then begin
  403.     GetModuleFileName(HInstance, FileName, SizeOf(FileName) - 1);
  404.     Result := StrPas(FileName);
  405.   end
  406.   else Result := ParamStr(0);
  407. end;
  408.  
  409. function AppVerInfo: TVersionInfo;
  410. begin
  411.   Result := TVersionInfo.Create(AppFileName);
  412. end;
  413.  
  414. { Installation utility routines }
  415.  
  416. function OkToWriteModule(ModuleName: string; NewVer: Longint): Boolean;
  417. { Return True if it's ok to overwrite ModuleName with NewVer }
  418. begin
  419.   {Assume we should overwrite}
  420.   OkToWriteModule := True;
  421.   with TVersionInfo.Create(ModuleName) do begin
  422.     try
  423.       if Valid then {Should we overwrite?}
  424.         OkToWriteModule := NewVer > VersionNum;
  425.     finally
  426.       Free;
  427.     end;
  428.   end;
  429. end;
  430.  
  431. end.